home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-auth.el.z / url-auth.el
Encoding:
Text File  |  1998-05-21  |  12.2 KB  |  319 lines
  1. ;;; url-auth.el --- Uniform Resource Locator authorization modules
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/22 16:44:35
  4. ;; Version: 1.9
  5. ;; Keywords: comm, data, processes, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'url-vars)
  30. (require 'url-parse)
  31.  
  32. (defsubst url-auth-user-prompt (url realm)
  33.   "String to usefully prompt for a username."
  34.   (concat "Username [for "
  35.       (or realm (url-truncate-url-for-viewing
  36.              (url-recreate-url url)
  37.              (- (window-width) 10 20)))
  38.       "]: "))
  39.  
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. ;;; Basic authorization code
  42. ;;; ------------------------
  43. ;;; This implements the BASIC authorization type.  See the online
  44. ;;; documentation at
  45. ;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
  46. ;;; for the complete documentation on this type.
  47. ;;;
  48. ;;; This is very insecure, but it works as a proof-of-concept
  49. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50. (defvar url-basic-auth-storage nil
  51.   "Where usernames and passwords are stored.  Its value is an assoc list of
  52. assoc lists.  The first assoc list is keyed by the server name.  The cdr of
  53. this is an assoc list based on the 'directory' specified by the url we are
  54. looking up.")
  55.  
  56. (defun url-basic-auth (url &optional prompt overwrite realm args)
  57.   "Get the username/password for the specified URL.
  58. If optional argument PROMPT is non-nil, ask for the username/password
  59. to use for the url and its descendants.  If optional third argument
  60. OVERWRITE is non-nil, overwrite the old username/password pair if it
  61. is found in the assoc list.  If REALM is specified, use that as the realm
  62. instead of the pathname inheritance method."
  63.   (let* ((href (if (stringp url)
  64.            (url-generic-parse-url url)
  65.          url))
  66.      (server (url-host href))
  67.      (port (or (url-port href) "80"))
  68.      (path (url-filename href))
  69.      user pass byserv retval data)
  70.     (setq server (concat server ":" port)
  71.       path (cond
  72.         (realm realm)
  73.         ((string-match "/$" path) path)
  74.         (t (url-basepath path)))
  75.       byserv (cdr-safe (assoc server url-basic-auth-storage)))
  76.     (cond
  77.      ((and prompt (not byserv))
  78.       (setq user (read-string (url-auth-user-prompt url realm)
  79.                   (user-real-login-name))
  80.         pass (funcall url-passwd-entry-func "Password: ")
  81.         url-basic-auth-storage
  82.         (cons (list server
  83.             (cons path
  84.                   (setq retval
  85.                     (base64-encode
  86.                      (format "%s:%s" user pass)))))
  87.           url-basic-auth-storage)))
  88.      (byserv
  89.       (setq retval (cdr-safe (assoc path byserv)))
  90.       (if (and (not retval)
  91.            (string-match "/" path))
  92.        (while (and byserv (not retval))
  93.         (setq data (car (car byserv)))
  94.         (if (or (not (string-match "/" data)) ; Its a realm - take it!
  95.             (and
  96.              (>= (length path) (length data))
  97.              (string= data (substring path 0 (length data)))))
  98.         (setq retval (cdr (car byserv))))
  99.         (setq byserv (cdr byserv))))
  100.       (if (or (and (not retval) prompt) overwrite)
  101.       (progn
  102.         (setq user (read-string (url-auth-user-prompt url realm)
  103.                     (user-real-login-name))
  104.           pass (funcall url-passwd-entry-func "Password: ")
  105.           retval (base64-encode (format "%s:%s" user pass))
  106.           byserv (assoc server url-basic-auth-storage))
  107.         (setcdr byserv
  108.             (cons (cons path retval) (cdr byserv))))))
  109.      (t (setq retval nil)))
  110.     (if retval (setq retval (concat "Basic " retval)))
  111.     retval))
  112.  
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114. ;;; Digest authorization code
  115. ;;; ------------------------
  116. ;;; This implements the DIGEST authorization type.  See the internet draft
  117. ;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
  118. ;;; for the complete documentation on this type.
  119. ;;;
  120. ;;; This is very secure
  121. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  122. (defvar url-digest-auth-storage nil
  123.   "Where usernames and passwords are stored.  Its value is an assoc list of
  124. assoc lists.  The first assoc list is keyed by the server name.  The cdr of
  125. this is an assoc list based on the 'directory' specified by the url we are
  126. looking up.")
  127.  
  128. (defun url-digest-auth-create-key (username password realm method uri)
  129.   "Create a key for digest authentication method"
  130.   (let* ((info (if (stringp uri)
  131.            (url-generic-parse-url uri)
  132.          uri))
  133.      (a1 (md5 (concat username ":" realm ":" password)))
  134.      (a2 (md5 (concat method ":" (url-filename info)))))
  135.     (list a1 a2)))
  136.  
  137. (defun url-digest-auth (url &optional prompt overwrite realm args)
  138.   "Get the username/password for the specified URL.
  139. If optional argument PROMPT is non-nil, ask for the username/password
  140. to use for the url and its descendants.  If optional third argument
  141. OVERWRITE is non-nil, overwrite the old username/password pair if it
  142. is found in the assoc list.  If REALM is specified, use that as the realm
  143. instead of hostname:portnum."
  144.   (if args
  145.       (let* ((href (if (stringp url)
  146.                (url-generic-parse-url url)
  147.              url))
  148.          (server (url-host href))
  149.          (port (or (url-port href) "80"))
  150.          (path (url-filename href))
  151.          user pass byserv retval data)
  152.     (setq path (cond
  153.             (realm realm)
  154.             ((string-match "/$" path) path)
  155.             (t (url-basepath path)))
  156.           server (concat server ":" port)
  157.           byserv (cdr-safe (assoc server url-digest-auth-storage)))
  158.     (cond
  159.      ((and prompt (not byserv))
  160.       (setq user (read-string (url-auth-user-prompt url realm)
  161.                   (user-real-login-name))
  162.         pass (funcall url-passwd-entry-func "Password: ")
  163.         url-digest-auth-storage
  164.         (cons (list server
  165.                 (cons path
  166.                   (setq retval
  167.                     (cons user
  168.                           (url-digest-auth-create-key
  169.                            user pass realm
  170.                            (or url-request-method "GET")
  171.                            url)))))
  172.               url-digest-auth-storage)))
  173.      (byserv
  174.       (setq retval (cdr-safe (assoc path byserv)))
  175.       (if (and (not retval)        ; no exact match, check directories
  176.            (string-match "/" path)) ; not looking for a realm
  177.           (while (and byserv (not retval))
  178.         (setq data (car (car byserv)))
  179.         (if (or (not (string-match "/" data))
  180.             (and
  181.              (>= (length path) (length data))
  182.              (string= data (substring path 0 (length data)))))
  183.             (setq retval (cdr (car byserv))))
  184.         (setq byserv (cdr byserv))))
  185.       (if (or (and (not retval) prompt) overwrite)
  186.           (progn
  187.         (setq user (read-string (url-auth-user-prompt url realm)
  188.                     (user-real-login-name))
  189.               pass (funcall url-passwd-entry-func "Password: ")
  190.               retval (setq retval
  191.                    (cons user
  192.                      (url-digest-auth-create-key
  193.                       user pass realm
  194.                       (or url-request-method "GET")
  195.                       url)))
  196.               byserv (assoc server url-digest-auth-storage))
  197.         (setcdr byserv
  198.             (cons (cons path retval) (cdr byserv))))))
  199.      (t (setq retval nil)))
  200.     (if retval
  201.         (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
  202.           (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
  203.           (format
  204.            (concat "Digest username=\"%s\", realm=\"%s\","
  205.                "nonce=\"%s\", uri=\"%s\","
  206.                "response=\"%s\", opaque=\"%s\"")
  207.            (nth 0 retval) realm nonce (url-filename href)
  208.            (md5 (concat (nth 1 retval) ":" nonce ":"
  209.                 (nth 2 retval))) opaque))))))
  210.  
  211. (defvar url-registered-auth-schemes nil
  212.   "A list of the registered authorization schemes and various and sundry
  213. information associated with them.")
  214.  
  215. ;;;###autoload
  216. (defun url-get-authentication (url realm type prompt &optional args)
  217.   "Return an authorization string suitable for use in the WWW-Authenticate
  218. header in an HTTP/1.0 request.
  219.  
  220. URL    is the url you are requesting authorization to.  This can be either a
  221.        string representing the URL, or the parsed representation returned by
  222.        `url-generic-parse-url'
  223. REALM  is the realm at a specific site we are looking for.  This should be a
  224.        string specifying the exact realm, or nil or the symbol 'any' to
  225.        specify that the filename portion of the URL should be used as the
  226.        realm
  227. TYPE   is the type of authentication to be returned.  This is either a string
  228.        representing the type (basic, digest, etc), or nil or the symbol 'any'
  229.        to specify that any authentication is acceptable.  If requesting 'any'
  230.        the strongest matching authentication will be returned.  If this is
  231.        wrong, its no big deal, the error from the server will specify exactly
  232.        what type of auth to use
  233. PROMPT is boolean - specifies whether to ask the user for a username/password
  234.        if one cannot be found in the cache"
  235.   (if (not realm)
  236.       (setq realm (cdr-safe (assoc "realm" args))))
  237.   (if (stringp url)
  238.       (setq url (url-generic-parse-url url)))
  239.   (if (or (null type) (eq type 'any))
  240.       ;; Whooo doogies!
  241.       ;; Go through and get _all_ the authorization strings that could apply
  242.       ;; to this URL, store them along with the 'rating' we have in the list
  243.       ;; of schemes, then sort them so that the 'best' is at the front of the
  244.       ;; list, then get the car, then get the cdr.
  245.       ;; Zooom zooom zoooooom
  246.       (cdr-safe
  247.        (car-safe
  248.     (sort
  249.      (mapcar
  250.       (function
  251.        (lambda (scheme)
  252.          (if (fboundp (car (cdr scheme)))
  253.          (cons (cdr (cdr scheme))
  254.                (funcall (car (cdr scheme)) url nil nil realm))
  255.            (cons 0 nil))))
  256.       url-registered-auth-schemes)
  257.      (function
  258.       (lambda (x y)
  259.         (cond
  260.          ((null (cdr x)) nil)
  261.          ((and (cdr x) (null (cdr y))) t)
  262.          ((and (cdr x) (cdr y))
  263.           (>= (car x) (car y)))
  264.          (t nil)))))))
  265.     (if (symbolp type) (setq type (symbol-name type)))
  266.     (let* ((scheme (car-safe
  267.             (cdr-safe (assoc (downcase type)
  268.                      url-registered-auth-schemes)))))
  269.       (if (and scheme (fboundp scheme))
  270.       (funcall scheme url prompt
  271.            (and prompt
  272.             (funcall scheme url nil nil realm args))
  273.            realm args)))))
  274.  
  275. ;;;###autoload
  276. (defun url-register-auth-scheme (type &optional function rating)
  277.   "Register an HTTP authentication method.
  278.  
  279. TYPE     is a string or symbol specifying the name of the method.   This
  280.          should be the same thing you expect to get returned in an Authenticate
  281.          header in HTTP/1.0 - it will be downcased.
  282. FUNCTION is the function to call to get the authorization information.  This
  283.          defaults to `url-?-auth', where ? is TYPE
  284. RATING   a rating between 1 and 10 of the strength of the authentication.
  285.          This is used when asking for the best authentication for a specific
  286.          URL.  The item with the highest rating is returned."
  287.   (let* ((type (cond
  288.         ((stringp type) (downcase type))
  289.         ((symbolp type) (downcase (symbol-name type)))
  290.         (t (error "Bad call to `url-register-auth-scheme'"))))
  291.      (function (or function (intern (concat "url-" type "-auth"))))
  292.      (rating (cond
  293.           ((null rating) 2)
  294.           ((stringp rating) (string-to-int rating))
  295.           (t rating)))
  296.      (node (assoc type url-registered-auth-schemes)))
  297.     (if (not (fboundp function))
  298.     (url-warn 'security
  299.           (format (eval-when-compile
  300.                 "Tried to register `%s' as an auth scheme"
  301.                 ", but it is not a function!") function)))
  302.  
  303.     (if node
  304.     (progn
  305.       (setcdr node (cons function rating))
  306.       (url-warn 'security
  307.             (format
  308.              "Replacing authorization method `%s' - this could be bad."
  309.              type)))
  310.       (setq url-registered-auth-schemes
  311.         (cons (cons type (cons function rating))
  312.           url-registered-auth-schemes)))))
  313.  
  314. (defun url-auth-registered (scheme)
  315.   ;; Return non-nil iff SCHEME is registered as an auth type
  316.   (assoc scheme url-registered-auth-schemes))
  317.  
  318. (provide 'urlauth)
  319.